home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 2010 April / PCWorld0410.iso / hity wydania / Ubuntu 9.10 PL / karmelkowy-koliberek-desktop-9.10-i386-PL.iso / casper / filesystem.squashfs / usr / bin / lwp-download < prev    next >
Text File  |  2009-08-15  |  8KB  |  324 lines
  1. #!/usr/bin/perl -w
  2.  
  3. eval 'exec /usr/bin/perl -w -S $0 ${1+"$@"}'
  4.     if 0; # not running under some shell
  5.  
  6. =head1 NAME
  7.  
  8. lwp-download - Fetch large files from the web
  9.  
  10. =head1 SYNOPSIS
  11.  
  12. B<lwp-download> [B<-a>] <I<url>> [<I<local path>>]
  13.  
  14. =head1 DESCRIPTION
  15.  
  16. The B<lwp-download> program will save the file at I<url> to a local
  17. file.
  18.  
  19. If I<local path> is not specified, then the current directory is
  20. assumed.
  21.  
  22. If I<local path> is a directory, then the basename of the file to save
  23. is picked up from the Content-Disposition header or the URL of the
  24. response.  If the file already exists, then B<lwp-download> will
  25. prompt before it overwrites and will fail if its standard input is not
  26. a terminal.  This form of invocation will also fail is no acceptable
  27. filename can be derived from the sources mentioned above.
  28.  
  29. If I<local path> is not a directory, then it is simply used as the
  30. path to save into.
  31.  
  32. The I<lwp-download> program is implemented using the I<libwww-perl>
  33. library.  It is better suited to down load big files than the
  34. I<lwp-request> program because it does not store the file in memory.
  35. Another benefit is that it will keep you updated about its progress
  36. and that you don't have much options to worry about.
  37.  
  38. Use the C<-a> option to save the file in text (ascii) mode.  Might
  39. make a difference on dosish systems.
  40.  
  41. =head1 EXAMPLE
  42.  
  43. Fetch the newest and greatest perl version:
  44.  
  45.  $ lwp-download http://www.perl.com/CPAN/src/latest.tar.gz
  46.  Saving to 'latest.tar.gz'...
  47.  11.4 MB received in 8 seconds (1.43 MB/sec)
  48.  
  49. =head1 AUTHOR
  50.  
  51. Gisle Aas <gisle@aas.no>
  52.  
  53. =cut
  54.  
  55. #' get emacs out of quote mode
  56.  
  57. use strict;
  58.  
  59. use LWP::UserAgent ();
  60. use LWP::MediaTypes qw(guess_media_type media_suffix);
  61. use URI ();
  62. use HTTP::Date ();
  63.  
  64. my $progname = $0;
  65. $progname =~ s,.*/,,;    # only basename left in progname
  66. $progname =~ s,.*\\,, if $^O eq "MSWin32";
  67. $progname =~ s/\.\w*$//; # strip extension if any
  68.  
  69. #parse option
  70. use Getopt::Std;
  71. my %opt;
  72. unless (getopts('a', \%opt)) {
  73.     usage();
  74. }
  75.  
  76. my $url = URI->new(shift || usage());
  77. my $argfile = shift;
  78. usage() if defined($argfile) && !length($argfile);
  79. my $VERSION = "5.827";
  80.  
  81. my $ua = LWP::UserAgent->new(
  82.    agent => "lwp-download/$VERSION ",
  83.    keep_alive => 1,
  84.    env_proxy => 1,
  85. );
  86.  
  87. my $file;      # name of file we download into
  88. my $length;    # total number of bytes to download
  89. my $flength;   # formatted length
  90. my $size = 0;  # number of bytes received
  91. my $start_t;   # start time of download
  92. my $last_dur;  # time of last callback
  93.  
  94. my $shown = 0; # have we called the show() function yet
  95.  
  96. $SIG{INT} = sub { die "Interrupted\n"; };
  97.  
  98. $| = 1;  # autoflush
  99.  
  100. my $res = $ua->request(HTTP::Request->new(GET => $url),
  101.   sub {
  102.       unless(defined $file) {
  103.       my $res = $_[1];
  104.  
  105.       my $directory;
  106.       if (defined $argfile && -d $argfile) {
  107.           ($directory, $argfile) = ($argfile, undef);
  108.       }
  109.  
  110.       unless (defined $argfile) {
  111.           # find a suitable name to use
  112.           $file = $res->filename;
  113.  
  114.           # if this fails we try to make something from the URL
  115.           unless ($file) {
  116.           my $req = $res->request;  # not always there
  117.           my $rurl = $req ? $req->uri : $url;
  118.  
  119.           $file = ($rurl->path_segments)[-1];
  120.           if (!defined($file) || !length($file)) {
  121.               $file = "index";
  122.               my $suffix = media_suffix($res->content_type);
  123.               $file .= ".$suffix" if $suffix;
  124.           }
  125.           elsif ($rurl->scheme eq 'ftp' ||
  126.                $file =~ /\.t[bg]z$/   ||
  127.                $file =~ /\.tar(\.(Z|gz|bz2?))?$/
  128.               ) {
  129.               # leave the filename as it was
  130.           }
  131.           else {
  132.               my $ct = guess_media_type($file);
  133.               unless ($ct eq $res->content_type) {
  134.               # need a better suffix for this type
  135.               my $suffix = media_suffix($res->content_type);
  136.               $file .= ".$suffix" if $suffix;
  137.               }
  138.           }
  139.           }
  140.  
  141.           # validate that we don't have a harmful filename now.  The server
  142.           # might try to trick us into doing something bad.
  143.           if (!length($file) ||
  144.                   $file =~ s/([^a-zA-Z0-9_\.\-\+\~])/sprintf "\\x%02x", ord($1)/ge)
  145.               {
  146.           die "Will not save <$url> as \"$file\".\nPlease override file name on the command line.\n";
  147.           }
  148.  
  149.           if (defined $directory) {
  150.               require File::Spec;
  151.               $file = File::Spec->catfile($directory, $file);
  152.           }
  153.  
  154.           # Check if the file is already present
  155.           if (-l $file) {
  156.           die "Will not save <$url> to link \"$file\".\nPlease override file name on the command line.\n";
  157.           }
  158.           elsif (-f _) {
  159.           die "Will not save <$url> as \"$file\" without verification.\nEither run from terminal or override file name on the command line.\n"
  160.               unless -t;
  161.           $shown = 1;
  162.           print "Overwrite $file? [y] ";
  163.           my $ans = <STDIN>;
  164.           unless (defined($ans) && $ans =~ /^y?\n/) {
  165.               if (defined $ans) {
  166.               print "Ok, aborting.\n";
  167.               }
  168.               else {
  169.               print "\nAborting.\n";
  170.               }
  171.               exit 1;
  172.           }
  173.           $shown = 0;
  174.           }
  175.           elsif (-e _) {
  176.           die "Will not save <$url> as \"$file\".  Path exists.\n";
  177.           }
  178.           else {
  179.           print "Saving to '$file'...\n";
  180.           }
  181.       }
  182.       else {
  183.           $file = $argfile;
  184.       }
  185.       open(FILE, ">$file") || die "Can't open $file: $!\n";
  186.           binmode FILE unless $opt{a};
  187.       $length = $res->content_length;
  188.       $flength = fbytes($length) if defined $length;
  189.       $start_t = time;
  190.       $last_dur = 0;
  191.       }
  192.  
  193.       print FILE $_[0] or die "Can't write to $file: $!\n";
  194.       $size += length($_[0]);
  195.  
  196.       if (defined $length) {
  197.       my $dur  = time - $start_t;
  198.       if ($dur != $last_dur) {  # don't update too often
  199.           $last_dur = $dur;
  200.           my $perc = $size / $length;
  201.           my $speed;
  202.           $speed = fbytes($size/$dur) . "/sec" if $dur > 3;
  203.           my $secs_left = fduration($dur/$perc - $dur);
  204.           $perc = int($perc*100);
  205.           my $show = "$perc% of $flength";
  206.           $show .= " (at $speed, $secs_left remaining)" if $speed;
  207.           show($show, 1);
  208.       }
  209.       }
  210.       else {
  211.       show( fbytes($size) . " received");
  212.       }
  213.   }
  214. );
  215.  
  216. if (fileno(FILE)) {
  217.     close(FILE) || die "Can't write to $file: $!\n";
  218.  
  219.     show("");  # clear text
  220.     print "\r";
  221.     print fbytes($size);
  222.     print " of ", fbytes($length) if defined($length) && $length != $size;
  223.     print " received";
  224.     my $dur = time - $start_t;
  225.     if ($dur) {
  226.     my $speed = fbytes($size/$dur) . "/sec";
  227.     print " in ", fduration($dur), " ($speed)";
  228.     }
  229.     print "\n";
  230.  
  231.     if (my $mtime = $res->last_modified) {
  232.     utime time, $mtime, $file;
  233.     }
  234.  
  235.     if ($res->header("X-Died") || !$res->is_success) {
  236.     if (my $died = $res->header("X-Died")) {
  237.         print "$died\n";
  238.     }
  239.     if (-t) {
  240.         print "Transfer aborted.  Delete $file? [n] ";
  241.         my $ans = <STDIN>;
  242.         if (defined($ans) && $ans =~ /^y\n/) {
  243.         unlink($file) && print "Deleted.\n";
  244.         }
  245.         elsif ($length > $size) {
  246.         print "Truncated file kept: ", fbytes($length - $size), " missing\n";
  247.         }
  248.         else {
  249.         print "File kept.\n";
  250.         }
  251.             exit 1;
  252.     }
  253.     else {
  254.         print "Transfer aborted, $file kept\n";
  255.     }
  256.     }
  257.     exit 0;
  258. }
  259.  
  260. # Did not manage to create any file
  261. print "\n" if $shown;
  262. if (my $xdied = $res->header("X-Died")) {
  263.     print "$progname: Aborted\n$xdied\n";
  264. }
  265. else {
  266.     print "$progname: ", $res->status_line, "\n";
  267. }
  268. exit 1;
  269.  
  270.  
  271. sub fbytes
  272. {
  273.     my $n = int(shift);
  274.     if ($n >= 1024 * 1024) {
  275.     return sprintf "%.3g MB", $n / (1024.0 * 1024);
  276.     }
  277.     elsif ($n >= 1024) {
  278.     return sprintf "%.3g KB", $n / 1024.0;
  279.     }
  280.     else {
  281.     return "$n bytes";
  282.     }
  283. }
  284.  
  285. sub fduration
  286. {
  287.     use integer;
  288.     my $secs = int(shift);
  289.     my $hours = $secs / (60*60);
  290.     $secs -= $hours * 60*60;
  291.     my $mins = $secs / 60;
  292.     $secs %= 60;
  293.     if ($hours) {
  294.     return "$hours hours $mins minutes";
  295.     }
  296.     elsif ($mins >= 2) {
  297.     return "$mins minutes";
  298.     }
  299.     else {
  300.     $secs += $mins * 60;
  301.     return "$secs seconds";
  302.     }
  303. }
  304.  
  305.  
  306. BEGIN {
  307.     my @ani = qw(- \ | /);
  308.     my $ani = 0;
  309.  
  310.     sub show
  311.     {
  312.         my($mess, $show_ani) = @_;
  313.         print "\r$mess" . (" " x (75 - length $mess));
  314.     print $show_ani ? "$ani[$ani++]\b" : " ";
  315.         $ani %= @ani;
  316.         $shown++;
  317.     }
  318. }
  319.  
  320. sub usage
  321. {
  322.     die "Usage: $progname [-a] <url> [<lpath>]\n";
  323. }
  324.